Option Explicit
Dim BookmarkType
Dim rsArticles
Dim CurrentBookmark
BookmarkType = vbEmpty
rsArticles = Null
CurrentBookmark = Null
Function VarAsType(Value, ValueType)
Select Case ValueType
Case vbInteger VarAsType = CInt(Value)
Case vbLong VarAsType = CLng(Value)
Case vbSingle VarAsType = CSng(Value)
Case vbDouble VarAsType = CDbl(Value)
Case vbCurrency VarAsType = CCur(Value)
Case vbDate VarAsType = CDate(Value)
Case vbString VarAsType = CStr(Value)
Case vbBoolean VarAsType = CBool(Value)
Case vbVariant VarAsType = Value 'Leave as is
Case vbByte VarAsType = CByte(Value)
Case Else Err.Raise 5, "Convertion", "Convertion failed"
End Select
End Function
Sub CleanupArticle()
document.all.inpArticleTitle.innerText = ""
document.all.inpArticleDescription.innerText = ""
document.all.inpArticleURL.innerText = ""
document.all.inpArticleDate.innerText = ""
document.all.inpArticleCategory.innerText = ""
document.all.inpArticleKeywords.innerText = ""
document.all.inpArticleAuthorNames.innerText = ""
document.all.inpArticleAuthorEmails.innerText = ""
End Sub
Sub CleanupArticles()
CleanupArticle()
document.all.tblArticleList.outerHTML = "
"
End Sub
Sub CleanupSite()
document.all.inpSiteTitle.innerText = ""
document.all.inpSiteDescription.innerText = ""
document.all.inpSiteURL.innerText = ""
document.all.inpSiteDetails.innerText = ""
document.all.inpSiteImageURL.innerText = ""
document.all.inpSiteFurtherReading.innerText = ""
document.all.inpSiteAuthorNames.innerText = ""
document.all.inpSiteAuthorEmails.innerText = ""
End Sub
Sub CleanupAll()
CleanupSite()
CleanupArticles()
End Sub
Sub SetInputText(RootNode, inputControl, NodePath)
Dim Node
Set Node = RootNode.selectSingleNode(NodePath)
If IsEmpty(Node) or IsNull(Node) or (Node is Nothing) Then Exit Sub
inputControl.innerText = Node.text
End Sub
' Retrieve authors name and email from dc:creator node
Sub FindAuthors(RootNode, ByRef Authors, ByRef Emails)
Dim Nodes, Node, i, AuthorText, Pos, Author, Email
Authors = ""
Emails = ""
Set Nodes = RootNode.selectNodes("./dc:creator")
For i = 0 To Nodes.length-1
Set Node = Nodes.item(i)
AuthorText = Node.text
Pos = InStr(1, AuthorText, "(mailto:", 1)
If Pos > 0 Then
Author = Trim(Mid(AuthorText, 1, Pos-1))
Email = Trim(Mid(AuthorText, Pos + Len("(mailto:")))
If (Len(Email) > 0) and (Mid(Email, Len(Email), 1) = ")") Then
Email = Mid(Email, 1, Len(Email) - 1)
End If
Else
Author = AuthorText
Email = ""
End If
If Len(Authors) > 0 Then Authors = Authors & "|"
Authors = Authors & Author
if Len(Emails) > 0 Then Emails = Emails & "|"
Emails = Emails & Email
Next
End Sub
Sub SetAuthors(RootNode)
Dim Authors, Emails
FindAuthors RootNode, Authors, Emails
document.all.inpSiteAuthorNames.innerText = Authors
document.all.inpSiteAuthorEmails.innerText = Emails
End Sub
Sub OpenChannel(Channel)
SetInputText Channel, document.all.inpSiteTitle, "./title"
SetInputText Channel, document.all.inpSiteDescription, "./description"
SetInputText Channel, document.all.inpSiteURL, "./link"
SetInputText Channel, document.all.inpSiteDetails, "./dc:publisher"
SetInputText Channel, document.all.inpSiteImageURL, "./image/@rdf:resource"
SetInputText Channel, document.all.inpSiteFurtherReading, "./fr:url"
SetAuthors Channel
End Sub
' Create new recordset
Sub CreateRecordset()
Dim rs
Set rs = CreateObject("ADODB.Recordset")
If Err.Number <> 0 Then
MsgBox("Create: " & Err.Description)
Exit Sub
End If
rs.Fields.Append "Title", 200, 255, &H64 'adVarChar, adFldUpdatable or adFldIsNullable or adFldMayBeNull
rs.Fields.Append "Description", 201, 4000, &HE4 'adLongVarChar, adFldUpdatable or adFldIsNullable or adFldMayBeNull or adFldLong
rs.Fields.Append "URL", 200, 255, &H64
rs.Fields.Append "Date", 200, 80, &H64
rs.Fields.Append "Category", 200, 50, &H64
rs.Fields.Append "Keywords", 200, 255, &H64
rs.Fields.Append "Author", 200, 255, &H64
rs.Fields.Append "Email", 200, 255, &H64
If Err.Number <> 0 Then
MsgBox("Add fields: " & Err.Description)
Exit Sub
End If
rs.Open
If Err.Number <> 0 Then
MsgBox("Open: " & Err.Description)
Exit Sub
End If
Set rsArticles = rs
End Sub
Sub SetColumnValue(RootNode, ColumnName, NodePath)
On Error Resume Next
Dim Node
Set Node = RootNode.selectSingleNode(NodePath)
If IsEmpty(Node) or IsNull(Node) or (Node Is Nothing) Then Exit Sub
rsArticles(ColumnName) = CStr(Node.text)
End Sub
Sub OpenItem(Item)
On Error Resume Next
Dim Authors, Emails
Authors = ""
Emails = ""
rsArticles.AddNew()
SetColumnValue Item, "Title", "./title"
SetColumnValue Item, "Description", "./description"
SetColumnValue Item, "URL", "./link"
SetColumnValue Item, "Date", "./dc:date"
SetColumnValue Item, "Category", "./pa:category"
SetColumnValue Item, "Keywords", "./pa:keywords"
FindAuthors Item, Authors, Emails
rsArticles("Author") = Authors
rsArticles("Email") = Emails
rsArticles.Update()
End Sub
Sub OnBtnOpenRSSClick()
CleanupAll()
rsArticles = Null
Dim xmlDoc, Channel, Items, Item, Node, i
Set xmlDoc = CreateObject("MsXml2.DOMDocument")
cDialog.Filter = "RSS files (*.xml)|*.xml|All files (*.*)|*.*"
cDialog.FileName = ""
cDialog.CancelError = True
On Error Resume Next
cDialog.ShowOpen()
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
xmlDoc.async = False
xmlDoc.validateOnParse = True
xmlDoc.Load(cDialog.FileName)
If xmlDoc.parseError.ErrorCode <> 0 Then
Err.Raise 5, "RSS Reader", xmlDoc.parseError.reason
End If
'Process only first channel, ignore others if any
Set Channel = xmlDoc.documentElement.selectSingleNode("./channel")
If IsEmpty(Channel) or IsNull(Channel) or (Channel is Nothing) Then
Err.Raise 5, "RSS Reader", "RSS File is invalid"
End If
OpenChannel(Channel)
CreateRecordset()
Set Items = xmlDoc.documentElement.selectNodes("./item")
For i = 0 to (Items.length - 1)
Set Item = Items.item(i)
OpenItem(Item)
Next
FillArticleList()
End Sub
Sub OnBtnImportADOClick()
Dim locator, conn
Set locator = CreateObject("DataLinks")
Set conn = locator.PromptNew()
If (IsEmpty(conn) or IsNull(conn) or (conn is Nothing)) Then Exit Sub
conn.Open()
On Error Resume Next
Dim strTableName
strTableName = PromptTableName(conn)
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
DoImport conn, strTableName
End Sub
Sub OnBtnImportAccessClick()
cDialog.Filter = "MS Access database files (*.mdb)|*.mdb"
cDialog.FileName = ""
cDialog.CancelError = True
Dim strTableName
strTableName = ""
On Error Resume Next
cDialog.ShowOpen()
If Err.Number <> 0 Then Exit Sub
Dim dbFileName
dbFileName = cDialog.FileName
Dim conn
Set conn = CreateObject("ADODB.Connection")
conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName)
strTableName = PromptTableName(conn)
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
DoImport conn, strTableName
End Sub
Sub OnBtnImportExcelClick()
cDialog.Filter = "MS Excel files (*.xls)|*.xls"
cDialog.FileName = ""
cDialog.CancelError = True
Dim strTableName
strTableName = ""
On Error Resume Next
cDialog.ShowOpen()
If Err.Number <> 0 Then Exit Sub
Dim dbFileName
dbFileName = cDialog.FileName
Dim conn
Set conn = CreateObject("ADODB.Connection")
conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName & _
";Extended properties=Excel 8.0;")
strTableName = PromptTableName(conn)
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
DoImport conn, strTableName
End Sub
Function PersistRSS()
PersistRSS = False
Dim res
res = RssHeader(document.all.inpSiteTitle.value, _
document.all.inpSiteDescription.value, _
document.all.inpSiteURL.value, _
document.all.inpSiteDetails.value, _
document.all.inpSiteImageURL.value, _
document.all.inpSiteFurtherReading.value, _
document.all.inpSiteAuthorNames.value, _
document.all.inpSiteAuthorEmails.value)
If Not res Then
MsgBox("Site information is not complete.")
Exit Function
End If
If Not IsNull(rsArticles) and Not (rsArticles.BOF and rsArticles.EOF) Then
rsArticles.MoveFirst()
While Not rsArticles.EOF
res = RssItem(rsArticles("Title"), rsArticles("Description"), rsArticles("URL"), _
rsArticles("Date"), rsArticles("Category"), rsArticles("Keywords"), _
rsArticles("Author"), rsArticles("Email"))
If Not res Then
MsgBox("Error writing article: " + rs("Title"))
Exit Function
End If
rsArticles.MoveNext()
Wend
End If
res = RssFooter()
If Not res Then
MsgBox("Can not write footer")
Exit Function
End If
PersistRSS = True
End Function
Sub OnBtnSaveRSSClick()
If Not PersistRSS Then Exit Sub
cDialog.Filter = "RSS files (*.xml)|*.xml|All files (*.*)|*.*"
cDialog.FileName = ""
cDialog.CancelError = True
On Error Resume Next
cDialog.ShowOpen()
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
Dim res
res = RssPersist(cDialog.FileName)
sRSSXML = ""
If Not res Then
MsgBox("Can not save file")
Exit Sub
End If
End Sub
Sub OnBtnExportADOClick()
Dim locator, conn
Set locator = CreateObject("DataLinks")
Set conn = locator.PromptNew()
If (IsEmpty(conn) or IsNull(conn) or (conn is Nothing)) Then Exit Sub
conn.Open()
On Error Resume Next
Dim strTableName
strTableName = PromptTableName(conn)
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
DoExport conn, strTableName
End Sub
Sub OnBtnExportAccessClick()
cDialog.Filter = "MS Access database files (*.mdb)|*.mdb"
cDialog.FileName = ""
cDialog.CancelError = True
Dim strTableName
strTableName = ""
On Error Resume Next
cDialog.ShowOpen()
If Err.Number <> 0 Then Exit Sub
Dim dbFileName
dbFileName = cDialog.FileName
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(dbFileName) Then
Dim cat
Set cat = CreateObject("ADOX.Catalog")
cat.Create("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName)
If Err.Number <> 0 Then
MsgBox Err.Description
Exit Sub
End If
Set cat = Nothing
End If
Set fso = Nothing
Dim conn
Set conn = CreateObject("ADODB.Connection")
conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName)
If Err.Number <> 0 Then
MsgBox Err.Description
Exit Sub
End If
On Error Resume Next
strTableName = PromptTableName(conn)
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
DoExport conn, strTableName
End Sub
Sub OnBtnExportToExcelClick()
cDialog.Filter = "MS Excel files (*.xls)|*.xls"
cDialog.FileName = ""
cDialog.CancelError = True
Dim strTableName
strTableName = ""
On Error Resume Next
cDialog.ShowOpen()
If Err.Number <> 0 Then Exit Sub
Dim dbFileName, conn
dbFileName = cDialog.FileName
Set conn = CreateObject("ADODB.Connection")
conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName & _
";Extended properties=Excel 8.0;")
If Err.Number <> 0 Then
MsgBox Err.Description
Exit Sub
End If
On Error Resume Next
strTableName = PromptTableName(conn)
If Err.Number <> 0 Then Exit Sub
On Error Goto 0
DoExport conn, strTableName
End Sub
Sub OnTblArticleListClick()
Dim srcElement
Set srcElement = window.event.srcElement
If srcElement.tagName <> "A" or IsNull(rsArticles) Then Exit Sub
CleanupArticle()
Dim strBookmark
strBookmark = CStr(srcElement.id)
If Len(strBookmark) > 3 Then
strBookmark = Mid(strBookmark, 4)
Else
Exit Sub
End If
CurrentBookmark = VarAsType(strBookmark, BookmarkType)
rsArticles.Bookmark = CurrentBookmark
On Error Resume Next
document.all.inpArticleTitle.value = CStr(rsArticles("Title"))
document.all.inpArticleDescription.value = CStr(rsArticles("Description"))
document.all.inpArticleURL.value = CStr(rsArticles("Url"))
document.all.inpArticleDate.value = CStr(rsArticles("Date"))
document.all.inpArticleCategory.value = CStr(rsArticles("Category"))
document.all.inpArticleKeywords.value = CStr(rsArticles("Keywords"))
document.all.inpArticleAuthorNames.value = CStr(rsArticles("Author"))
document.all.inpArticleAuthorEmails.value = CStr(rsArticles("Email"))
End Sub
Function PromptTableName(conn)
'PromptTableName = window.prompt("Table name:", "Articles")
PromptTableName = CStr(window.showModalDialog("ChooseTable.html", conn, _
"dialogHeight: 350px; dialogWidth: 400px; center: yes; help: no; resizable: no; status: no"))
If PromptTableName = "" Then Err.Raise 5
End Function
Sub FillArticleList()
Dim strArticles
strArticles = "
" & vbCRLF
On Error Resume Next
rsArticles.MoveFirst()
If Err.Number <> 0 Then Exit Sub
BookmarkType = VarType(rsArticles.Bookmark)
While Not rsArticles.EOF
Dim strRow
strRow = "
" & vbCRLF
'Bookmark is stored in ID attribute as "artXXX"
strRow = strRow & "